home *** CD-ROM | disk | FTP | other *** search
/ The Arsenal Files 8 / The Arsenal Files Collection #8 (Arsenal Computer) (1996).ISO / prg_basi / pa32v305.zip / TEST40.BAS < prev    next >
BASIC Source File  |  1996-05-11  |  11KB  |  387 lines
  1. Attribute VB_Name = "FileModule"
  2. ' Tuomas Salste
  3. ' File name parsing library
  4. ' Included as an example for Project Analyzer
  5. ' These functions will not necessarily work
  6.  
  7. Option Explicit
  8. DefInt A-Z
  9.  
  10. Type FilenameType
  11.    drive As String '* 8
  12.    Path As String '* 63
  13.    Filename As String '* 12
  14.    Basename As String '* 8
  15.    Extension As String '* 3
  16. End Type
  17.  
  18. ' Global and Public mean the same here
  19. Global FName As FilenameType
  20. Public FName2 As FilenameType
  21.  
  22. ' Different types of Consts
  23. Global Const DRIVE_FLOPPY = 2
  24. Public Const DRIVE_FIXED = 1
  25. Private Const DRIVE_NETWORK = 0
  26. Const DRIVE_CRASHED = -1 ' This is Private
  27.  
  28. ' DiskSpaceFree function uses this in SETUPKIT.DLL
  29. ' Not needed if not used
  30. Declare Function DiskSpaceFree_DLL Lib "SETUPKIT.DLL" Alias "DiskSpaceFree" () As Long
  31.  
  32. Function AbsPath(ByVal BaseDir As String, ByVal Path As String) As String
  33. ' Gives Absolute Path from Relative Path
  34.  
  35. Dim GivenPath As FilenameType
  36. Dim Result As Integer
  37. Result = FileNameSplit(Path, GivenPath)
  38. If GivenPath.drive <> "" Then
  39.     On Error Resume Next
  40.     BaseDir = CurDir(GivenPath.drive)
  41.     If Err Then
  42.         BaseDir = GivenPath.drive + "\"
  43.     End If
  44.     On Error GoTo 0
  45. Else
  46.     If BaseDir = "" Then
  47.         BaseDir = CurDir
  48.     End If
  49. End If
  50.  
  51. Dim nDir As String
  52. Do While Path <> ""
  53.     nDir = NextDir(Path)
  54.     Select Case nDir
  55.         Case ".."
  56.             Dim BackPath As FilenameType
  57.             Result = FileNameSplit(BaseDir, BackPath)
  58.             BaseDir = BackPath.Path
  59.         Case "."
  60.         Case "\"
  61.             BaseDir = DriveOnly(BaseDir) + "\"
  62.         Case Else
  63.             BaseDir = PathNameWithSlash(BaseDir) & nDir
  64.     End Select
  65. Loop
  66. AbsPath = UCase(BaseDir)
  67.  
  68. End Function
  69.  
  70. Function Basenameonly(ByVal FileSpec As String) As String
  71. ' Returns the base name of a filespec
  72. ' FileSpec can be a directory name too
  73.  
  74. Dim Filename As FilenameType
  75. Dim Result As Integer
  76. Result = FileNameSplit(FileSpec, Filename)
  77. Basenameonly = Filename.Basename
  78.  
  79. End Function
  80.  
  81. Function ChangeFilenameExtension(ByVal OldFilename As String, ByVal NewExtension As String) As String
  82. ' Example:
  83. ' ChangeFilenameExtension("AUTOEXEC.BAT", "TMP")
  84. ' results in "AUTOEXEC.TMP"
  85. ' Returns "" in error
  86.  
  87. Dim File As FilenameType
  88. If FileNameSplit(OldFilename, File) Then
  89.     File.Extension = NewExtension
  90.     File.Filename = File.Basename & "." & File.Extension
  91.     ChangeFilenameExtension = FileNameExpand(File)
  92. Else
  93.     Exit Function
  94. End If
  95.  
  96. End Function
  97.  
  98. '------------------------------------------------
  99. ' Get the disk space free for the current drive
  100. '------------------------------------------------
  101. Function DiskSpaceFree(drive As String) As Long
  102. Dim OldDrive As String
  103. OldDrive = DriveOnly(CurDir)
  104.  
  105. On Error Resume Next
  106. ChDrive drive
  107. If Err = 0 Then
  108.     DiskSpaceFree = DiskSpaceFree_DLL()
  109. End If
  110. ChDrive OldDrive
  111.  
  112. End Function
  113.  
  114. Function DriveOnly(ByVal FileSpec As String) As String
  115. ' Returns the drive "D:"
  116.  
  117. Dim File As FilenameType
  118. If FileNameSplit(FileSpec, File) Then
  119.     DriveOnly = File.drive
  120. End If
  121.  
  122. End Function
  123.  
  124. Function DriveType(ByVal DriveLetter As String, DriveListBox As DriveListBox) As Integer
  125. ' Returns the type of a drive
  126. ' Type is one of the following:
  127. ' DRIVE_FLOPPY, DRIVE_FIXED, DRIVE_NETWORK
  128.  
  129. Dim i As Integer
  130. For i = 0 To DriveListBox.ListCount - 1
  131.     If StrComp(Left(DriveListBox.List(i), 1), Left(DriveLetter, 1), 1) = 0 Then
  132.         If Len(DriveListBox.List(i)) = 2 Then
  133.             DriveType = DRIVE_FLOPPY
  134.         ElseIf Mid(DriveListBox.List(i), 3, 2) = "\\" Then
  135.             DriveType = DRIVE_NETWORK
  136.         Else
  137.             
  138.             DriveType = DRIVE_FIXED
  139.         End If
  140.         Exit For
  141.     End If
  142. Next
  143.  
  144. End Function
  145.  
  146. Function ExtensionOnly(ByVal File As String) As String
  147. ' Returns file name extension "BAS"
  148. ' This is a global function that will be overridden
  149. ' by local function ExtensionOnly defined in PROJTEST.FRM
  150. ' So this function is dead
  151.  
  152. Dim Filename As FilenameType
  153. Dim Result As Integer
  154. Result = FileNameSplit(File, Filename)
  155. ExtensionOnly = Filename.Extension
  156.  
  157. End Function
  158.  
  159. Private Function FileNameExpand(Filename As FilenameType) As String
  160. ' Assembles a qualified file name from separate fields
  161.  
  162. Dim Delimiter$
  163. If Len(RTrim$(Filename.drive)) > 2 Then
  164.     If Filename.drive = String$(8, 0) Then
  165.         FileNameExpand$ = ""
  166.     Else
  167.         FileNameExpand$ = RTrim$(Filename.drive)
  168.     End If
  169. Else
  170.     If Right$(RTrim$(Filename.Path), 1) = ":" Or RTrim$(Filename.Path) = "" Or Right$(RTrim$(Filename.Path), 1) = "\" Then
  171.     Else
  172.         Delimiter$ = "\"
  173.     End If
  174.     If Left$(Filename.Path, 2) = RTrim$(Filename.drive) Then
  175.         FileNameExpand$ = UCase$(RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  176.     Else
  177.         FileNameExpand$ = UCase$(RTrim$(Filename.drive) + RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  178.     End If
  179. End If
  180.  
  181. End Function
  182.  
  183. Function FilenameOnly(ByVal FileSpec As String) As String
  184. ' Returns the file name part of a FileSpec "FILENAME.BAS"
  185.  
  186. Dim File As FilenameType
  187. If FileNameSplit(FileSpec, File) Then
  188.     FilenameOnly = File.Filename
  189. End If
  190.  
  191. End Function
  192.  
  193. Function FileNameSplit(ByVal FilenameString$, Filename As FilenameType) As Integer
  194. ' Splits a file name into separate fields
  195.  
  196. Dim er As Integer
  197. Dim FilNam$
  198. Dim Colon As Integer
  199. Dim NoDrive As Integer
  200. Dim c As Integer
  201.  
  202. FilNam$ = UCase$(FilenameString$)
  203. Filename.drive = ""
  204. Filename.Path = ""
  205. Filename.Filename = ""
  206. Filename.Basename = ""
  207. Filename.Extension = ""
  208. Colon = InStr(FilNam$, ":")
  209. If Colon = 2 Then
  210.     Filename.drive = Left$(FilNam$, 2)
  211. ElseIf Colon Then
  212.     If Len(FilNam$) > Colon Or Colon < 4 Or Colon > 5 Then
  213.         er = True
  214.     Else
  215.         NoDrive = True
  216.         Filename.drive = Left$(FilNam$, Colon)
  217.     End If
  218. End If
  219. If er = 0 And NoDrive = False Then
  220.     For c = Len(FilNam$) To 1 + Len(RTrim$(Filename.drive)) Step -1
  221.         If Mid$(FilNam$, c, 1) = "\" Then
  222.             If c = Len(RTrim$(Filename.drive)) + 1 Then
  223.                 Filename.Path = Left$(FilNam$, c)
  224.             Else
  225.                 Filename.Path = Left$(FilNam$, c - 1)
  226.             End If
  227.             Exit For
  228.         End If
  229.     Next
  230.     If RTrim$(Mid$(FilNam$, c + 1)) <> ".." Then
  231.         If InStr(Mid$(FilNam$, c + 1), ".") Then
  232.             Filename.Basename = Left$(Left$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") - 1), 8)
  233.             Filename.Extension = Mid$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") + 1, 3)
  234.         Else
  235.             Filename.Basename = Mid$(FilNam$, c + 1)
  236.         End If
  237.     Else
  238.         Filename.Path = RTrim$(Filename.Path) + ".."
  239.     End If
  240.     If RTrim$(Filename.Basename) = "" And RTrim$(Filename.Extension) <> "" Then
  241.         er = True
  242.         Filename.Extension = ""
  243.         Filename.Path = ""
  244.         Filename.drive = ""
  245.     Else
  246.         If Len(RTrim$(Filename.Extension)) Then
  247.             Filename.Filename = RTrim$(Filename.Basename) + "." + Filename.Extension
  248.         Else
  249.             Filename.Filename = RTrim$(Filename.Basename)
  250.         End If
  251.         If RTrim$(Filename.Filename) = "." Then Filename.Filename = ""
  252.     End If
  253. End If
  254. If er Then
  255.     FileNameSplit% = False
  256. Else
  257.     FileNameSplit% = True
  258. End If
  259.  
  260. End Function
  261.  
  262. Function IsDir(ByVal FileSpec As String) As Integer
  263.  
  264. Dim Result As Integer
  265. On Local Error Resume Next
  266. Result = GetAttr(FileSpec)
  267. If Err = 0 And Result = 16 Then ' ATTR_DIRECTORY= 16
  268.     IsDir = True
  269. End If
  270.  
  271. End Function
  272.  
  273. Function IsFile(ByVal FileSpec As String) As Integer
  274. ' Returns True if a file called Filename exists
  275. ' Filename CAN NOT contain wildcards
  276.  
  277. Dim Result As String
  278. On Local Error Resume Next
  279. Result = Dir(FileSpec)
  280. If Err = 0 And LCase(Result) = LCase(FilenameOnly(FileSpec)) And Result <> "" Then
  281.     IsFile = True
  282. End If
  283.  
  284. End Function
  285.  
  286. Function IsFileSpec(ByVal Filename As String) As Integer
  287. ' Returns True if Filename is
  288. ' a file, a directory or a volume label
  289. ' Filename must not contain any wildcards
  290.  
  291. Dim Result As Integer
  292. On Local Error Resume Next
  293. Result = GetAttr(Filename)
  294. If Err = 0 Then IsFileSpec = True
  295.  
  296. End Function
  297.  
  298. Function MatchesTemplate%(TestText$, Template$)
  299. ' Checks if a file name matches Template ("FILENAME.BAS", "*.BAS")
  300.  
  301. Dim CheckLen As Integer, c As Integer
  302. Dim TChar$, NoMatch As Integer
  303.  
  304. If Len(Template$) > Len(TestText$) Then
  305.     CheckLen = Len(Template$)
  306. Else
  307.     CheckLen = Len(TestText$)
  308. End If
  309. For c = 1 To CheckLen
  310.     TChar$ = Mid$(Template$, c, 1)
  311.     Select Case TChar$
  312.         Case "?"
  313.         Case "*"
  314.             Exit For
  315.         Case Mid$(TestText$, c, 1)
  316.         Case ""
  317.             NoMatch = True
  318.             Exit For
  319.         Case Else
  320.             NoMatch = True
  321.             Exit For
  322.     End Select
  323. Next
  324. If Len(Template$) > Len(TestText$) Then
  325.     If InStr(Template$, "*") = False And Mid$(Template$, Len(TestText$) + 1, Len(Template$) - Len(TestText$)) <> String$(Len(Template$) - Len(TestText$), "?") Then
  326.         NoMatch = True
  327.     End If
  328. End If
  329. If Not NoMatch Then MatchesTemplate = True
  330.  
  331. End Function
  332.  
  333. Function NextDir(Path As String) As String
  334. ' Returns the next directory name in a long Path string
  335. ' NextDir("D:\VB30\LIB\FILENAME.BAS") = "VB30"
  336.  
  337. Dim NewPath As String
  338. If Mid(Path, 2, 1) = ":" Then
  339.     NewPath = Mid(Path, 3)
  340. Else
  341.     NewPath = Path
  342. End If
  343. Select Case InStr(NewPath, "\")
  344.     Case 0
  345.         NextDir = NewPath
  346.         Path = ""
  347.     Case 1
  348.         NextDir = "\"
  349.         Path = Mid(NewPath, 2)
  350.     Case Else
  351.         NextDir = Left(NewPath, InStr(NewPath, "\") - 1)
  352.         Path = Mid(NewPath, InStr(NewPath, "\") + 1)
  353. End Select
  354.  
  355. End Function
  356.  
  357.  
  358. Function PathnameWithoutSlash(ByVal FileSpec As String) As String
  359. ' Returns a path name from a filespec without the ending slash
  360. ' The result can be used in ChDir, for example
  361. ' PathnameWithoutSlash("D:\VB30\LIB\FILENAME.BAS") = "D:\VB30\LIB"
  362.  
  363. Dim File As FilenameType
  364. If FileNameSplit(FileSpec, File) Then
  365.     PathnameWithoutSlash = File.Path
  366. End If
  367.  
  368. End Function
  369.  
  370. Function PathNameWithSlash(ByVal Path$) As String
  371. ' Returns a path name without the ending slash
  372. ' The result can be used in building filespecs, for example
  373. ' PathnameWithSlash("D:\VB30\LIB") = "D:\VB30\LIB\"
  374.  
  375. If Right$(RTrim$(Path$), 1) = ":" Or RTrim$(Path$) = "" Or Right$(RTrim$(Path$), 1) = "\" Then
  376.     PathNameWithSlash = Path$
  377. Else
  378.     If IsFile(Path$) Then
  379.         PathNameWithSlash = PathNameWithSlash(AbsPath(Path$, ".."))
  380.     Else
  381.         PathNameWithSlash = Path$ + "\"
  382.     End If
  383. End If
  384.  
  385. End Function
  386.  
  387.